home *** CD-ROM | disk | FTP | other *** search
- KERMIT TITLE 'Kermit -- MTS Version'
- * The Kermit protocol was designed at Columbia University in
- * in New York by Frank da Cruz, Bill Catchings and Daphne Tzoar.
- *
- * Copyright (c) 1983 Myrias Research Corporation
- * All rights reserved.
- *
- * This grotty piece of trash thrown together by Chris Thomson.
- SPACE 2
- * This program is invoked by:
- *
- * $run kermit [scards=in] [sprint=out] [0=*net*] [par={s|m}]
- *
- * s=server mode; m=master mode
- *
- * If no par= is given, and 0 is assigned, then the default is
- * master mode; if 0 is not assigned, the default is server.
- * In master mode, commands are read from scards and output is
- * sent to sprint. If you want to set any non-default parameters
- * before entering server mode, use par=m. See set command for
- * parameters.
- TITLE 'Initialization'
- PRINT NOGEN
- KERMIT CSECT
- REQU TYPE=DEC
- SAVE (14,12),,* Standard linkage
- LR R12,R15
- USING KERMIT,R12
- LA R11,2048(,R12)
- LA R11,2048(,R11)
- USING KERMIT+4096,R11
- LA R10,2048(,R11)
- LA R10,2048(,R10)
- USING KERMIT+8192,R10
- LA R15,SAVEAREA
- ST R13,4(,R15)
- ST R15,8(,R13)
- LR R13,R15
- LR R2,R1 Save parameter, if any
- MVI SERVER,1 Server if no unit 0
- MVI NETDEV,X'FF' Assume no net device
- MVI FILETYPE,C'T' Default to filetype=text
- MVI EOLCHAR,13 Default to eolchar=13 (CR)
- MVI EOLCHAR2,13
- XC NPAD,NPAD No outbound padding
- MVI PADCHAR,0 Pad character of NUL
- MVI DEBUG,0 Debugging output off
- LA R1,=C'-DEBUG(*L+1) ' But set up unit just in case
- CALL GETFD
- ST R0,DEBUNIT
- SR R0,R0 Get info about unit 0
- CALL GDINFO
- LTR R15,R15
- BNZ INIT30
- MVI SERVER,0
- CLI 13(R1),9 Error if not net
- BE INIT10
- SPRINT ' Unit 0 must be a network device'
- B ERREXIT
- INIT10 L R3,36(,R1) FDname of device
- LH R4,0(,R3) Length of it
- S R4,=F'1'
- C R4,=F'31'
- BNH INIT20
- SPRINT ' Unit 0 FDname too long'
- B ERREXIT
- INIT20 MVC NETDEV(32),=CL32' ' Copy device name for connect cmd
- EX R4,NDMVC
- SR R0,R0 Free gdinfo area
- CALL FREESPAC
- B INIT30
- NDMVC MVC NETDEV(*-*),2(R3)
- INIT30 LTR R2,R2
- BZ INIT60 No parameter
- L R2,0(,R2)
- LTR R2,R2
- BZ INIT60
- CLC 0(2,R2),=H'0'
- BE INIT60
- CLC 0(2,R2),=H'1' Parameter must be 1 character
- BNE INIT50
- CLI 2(R2),C'S' Parameter can override server/master
- BNE INIT40 default value
- MVI SERVER,1
- B INIT60
- INIT40 CLI 2(R2),C'M'
- BNE INIT50
- MVI SERVER,0
- B INIT60
- INIT50 SERCOM ' Invalid par field'
- B ERREXIT
- INIT60 LA R1,PFXPAR Set prefix to Kermit-MTS>
- CALL CUINFO
- B MAINLOOP
- TITLE 'Main command loop'
- MAINLOOP CLI SERVER,0 Are we a server?
- BZ LOCCMD No -- read a local command
- B REMCMD Yes -- read a remote command
- SPACE 1
- ABORT CLI NETDEV,X'FF'
- BE ABORT10
- SPRINT ' Aborted -- try again'
- MVI PACKET,ASCB Send break packet
- MVI WPCKTNUM,0
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- ABORT10 MVC PACKET(21),=C'EAborted -- try again'
- MVI WPCKTNUM,0
- LA R1,21
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- ERRPCKT BAL R9,TRATOE
- MVC SCBUF(15),=C' Remote error: ' Use scards buffer
- S R1,=F'2'
- BL ERRP10
- EX R1,ERRPMVC
- ERRP10 LA R1,16(,R1)
- STH R1,SCLEN
- CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
- B MAINLOOP
- ERRPMVC MVC SCBUF+15(*-*),PACKET+1
- SPACE 1
- WRTFERR CLI NETDEV,X'FF'
- BE WRTFE10
- SPRINT ' Bad return code writing to file'
- MVI PACKET,ASCB Send break packet
- MVI WPCKTNUM,0
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- WRTFE10 MVC PACKET(32),=C'EBad return code writing to file'
- MVI WPCKTNUM,0
- LA R1,32
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- PTOOLONG CLI NETDEV,X'FF'
- BE PTL10
- SPRINT ' Packet too long -- aborting'
- MVI PACKET,ASCB Send break packet
- MVI WPCKTNUM,0
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- PTL10 MVC PACKET(28),=C'EPacket too long -- aborting'
- MVI WPCKTNUM,0
- LA R1,28
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- ERREXIT LA R15,4
- B COMEXIT
- EXIT SR R15,R15
- COMEXIT L R13,4(,R13) Standard return sequence
- L R14,12(,R13)
- LM R0,R12,20(R13)
- BR R14
- TITLE 'Server command loop'
- REMCMD MVI WPCKTNUM,0
- BAL R9,RDPACKET Get a packet -- this may take a while
- BNZ REMCMDE
- BAL R9,TRATOE
- CLI PACKET,C'S' Send-initiate
- BE GOTS
- CLI PACKET,C'R' Receive-initiate
- BE GOTR
- CLI PACKET,C'C'
- BE DOCMD
- CLI PACKET,C'G'
- BE GOTG
- MVC PACKET(38),=C'EUnsupported or invalid server request'
- LA R1,38
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- REMCMDE MVI PACKET,ASCN
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- GOTR LR R2,R1 Set up to merge with SEND
- LA R1,PACKET+1
- S R2,=F'1'
- LA R3,0(R1,R2)
- MVI 0(R3),X'FF'
- BH SENDSRV *** cc set above ***
- MVC PACKET(37),=C'EMissing file spec in rcv-init packet'
- LA R1,37
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- DOCMD S R1,=F'1' Execute an MTS command
- ST R1,CMDLEN
- LA R1,PACKET+1
- ST R1,CMDPTR
- LA R1,CMDPTR
- CALL CMD
- MVI PACKET,ASCY Send ack
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- GOTG CLI PACKET+1,C'L'
- BE SLOGOUT
- CLI PACKET+1,C'F'
- BE SFINISH
- MVC PACKET(42),=C'EOnly F and L server generics supported'
- LA R1,42
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SPACE 1
- SFINISH MVI PACKET,ASCY Send acknowledgement
- LA R1,1
- BAL R9,WRPACKET
- B EXIT
- SPACE 1
- SLOGOUT MVI PACKET,ASCY Send acknowledgement
- LA R1,1
- BAL R9,WRPACKET
- CMD '$SIGNOFF $'
- DC H'0'
- TITLE 'Master command loop'
- LOCCMD CALL SCARDS,(SCBUF,SCLEN,SCMOD,SCLNUM)
- LA R1,SCBUF
- LH R2,SCLEN
- EX R2,CMDTR
- LA R3,0(R1,R2)
- MVI 0(R3),X'FF' Delimit the command for easy parsing
- BAL R9,SPNBL Span blanks on the front
- CLI 0(R1),C'$' Check for MTS command
- BNE CMD10
- CMD (R1),(R2) Perform MTS command
- B MAINLOOP
- CMD10 LR R3,R1
- BAL R9,BRKBL Break on a blank
- LR R4,R1 Length of word
- SR R4,R3
- S R4,=F'1' (-1 for ex)
- BL MAINLOOP Line was all blank
- LA R5,CMDTAB Point at command table
- CMD20 C R4,4(,R5) Meet minimum length requirement?
- BL CMD30 No
- EX R4,CMDCLC Match prefix of command?
- BNE CMD30 No
- L R3,0(,R5) Yes -- branch to handler
- BR R3
- CMD30 LA R5,CMDELEN(,R5) Next command table entry
- CLC 0(4,R5),=F'0' Error if end of table
- BNE CMD20
- SPRINT ' Invalid command. Valid commands are:'
- SPRINT ' bye, connect, display, exit, finish, help, logout,'
- SPRINT ' receive, set, send, server, show, stop, and ?'
- B MAINLOOP
- CMDTR TR 0(*-*,R1),LCUC
- CMDCLC CLC 0(*-*,R3),8(R5)
- SPACE 1
- SPNBL CLI 0(R1),C' ' Skip over blanks to end of line
- BNER R9
- LA R1,1(,R1)
- S R2,=F'1'
- BH SPNBL
- BR R9
- SPACE 1
- BRKBL CLI 0(R1),C' ' Stop at a blank or end of line
- BER R9
- LTR R2,R2
- BZR R9
- LA R1,1(,R1)
- S R2,=F'1'
- BH BRKBL
- BR R9
- SPACE 1
- BRKEQ CLI 0(R1),C'=' Stop at an = or end of line
- BER R9
- LTR R2,R2
- BZR R9
- LA R1,1(,R1)
- S R2,=F'1'
- BH BRKEQ
- BR R9
- SPACE 1
- * First word is handler address
- * Second word is minimum abbreviation length minus one
- * Third part is string; must have at least one trailing blank
- * for the parsing code to work correctly
- CMDTAB DC A(BYE),F'0',CL16'BYE'
- DC A(CONNECT),F'0',CL16'CONNECT'
- DC A(SHOW),F'0',CL16'DISPLAY'
- DC A(EXIT),F'0',CL16'EXIT'
- DC A(FINISH),F'0',CL16'FINISH'
- DC A(HELP),F'0',CL16'HELP'
- DC A(LOGOUT),F'0',CL16'LOGOUT'
- DC A(RECEIVE),F'0',CL16'RECEIVE'
- DC A(SET),F'2',CL16'SET'
- DC A(SEND),F'2',CL16'SEND'
- DC A(ENSERV),F'2',CL16'SERVER'
- DC A(SHOW),F'1',CL16'SHOW'
- DC A(EXIT),F'1',CL16'STOP'
- DC A(HELP),F'0',CL16'?'
- DC A(0)
- CMDELEN EQU 24
- TITLE 'Commands -- server, bye, logout, finish'
- ENSERV MVI SERVER,1
- B MAINLOOP
- SPACE 1
- BYE XC RETRYCNT,RETRYCNT
- BYEL L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVC PACKET(2),=C'GL' Send generic logout packet
- MVI WPCKTNUM,0
- LA R1,2
- BAL R9,TRETOA
- BAL R9,WRPACKET
- BAL R9,RDPACKET Read response
- BNZ BYEL
- BAL R9,TRATOE
- CLI PACKET,C'Y'
- BE EXIT Shut down if ack
- CLI PACKET,C'N' Loop if nak
- BE BYEL
- B ABORT Others are errors
- SPACE 1
- LOGOUT XC RETRYCNT,RETRYCNT
- LOGOUTL L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVC PACKET(2),=C'GL' Send generic logout packet
- MVI WPCKTNUM,0
- LA R1,2
- BAL R9,TRETOA
- BAL R9,WRPACKET
- BAL R9,RDPACKET Read response
- BNZ LOGOUTL
- BAL R9,TRATOE
- CLI PACKET,C'Y'
- BE MAINLOOP Next command if ack
- CLI PACKET,C'N'
- BE LOGOUTL
- B ABORT
- SPACE 1
- FINISH XC RETRYCNT,RETRYCNT
- FINISHL L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVC PACKET(2),=C'GF' Send generic finish packet
- LA R1,2
- BAL R9,TRETOA
- BAL R9,WRPACKET
- BAL R9,RDPACKET Read response
- BNZ FINISHL
- BAL R9,TRATOE
- CLI PACKET,C'Y'
- BE MAINLOOP Next command if ack
- CLI PACKET,C'N'
- BE FINISHL
- B ABORT
- TITLE 'Commands -- help, connect, show'
- HELP SPRINT ' The following commands are supported:'
- SPRINT ' $... an MTS command'
- SPRINT ' bye log out remote and exit local kermit'
- SPRINT ' connect emulate terminal on remote system'
- SPRINT ' display display various set parameters'
- SPRINT ' exit exit local kermit; remote unaffected'
- SPRINT ' finish exit but don''t log out remote kermit'
- SPRINT ' help what you''re reading'
- SPRINT ' receive receive one or more files'
- SPRINT ' send send one or more files'
- SPRINT ' server make local kermit into a server'
- SPRINT ' set set various parameters'
- SPRINT ' show save as display'
- SPRINT ' stop same as exit'
- SPRINT ' ? same as help'
- SPRINT ' For more on parameters, enter set ?'
- B MAINLOOP
- SPACE 1
- CONNECT CLI NETDEV,X'FF' Is there a network device?
- BNE CONN10 Yes
- SPRINT ' Unit 0 not assigned to network device'
- B MAINLOOP
- CONN10 SPRINT ' Calling net dsr; use @stop to return to kermit'
- LA R1,NETCMD
- CALL CMD
- B MAINLOOP
- SPACE 1
- SHOW SPRINT ' The following parameter values are set:'
- MVC SCBUF(12),=C' filetype='
- CLI FILETYPE,C'T'
- BNE SHOW10
- MVC SCBUF+12(5),=C'text '
- B SHOW20
- SHOW10 MVC SCBUF+12(5),=C'saved'
- SHOW20 LA R1,17
- STH R1,SCLEN
- CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
- MVC SCBUF(13),=C' endofline='
- SR R1,R1
- IC R1,EOLCHAR
- CVD R1,WORK
- UNPK SCBUF+13(2),WORK(8)
- OI SCBUF+14,C'0'
- LA R1,15
- STH R1,SCLEN
- CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
- MVC SCBUF(9),=C' debug='
- CLI DEBUG,0
- BNE SHOW30
- MVC SCBUF+9(3),=C'off'
- B SHOW40
- SHOW30 MVC SCBUF+9(3),=C'on '
- SHOW40 LA R1,12
- STH R1,SCLEN
- CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
- B MAINLOOP
- TITLE 'Commands -- set'
- SET BAL R9,SPNBL Extract parameter=value pair
- CLI 0(R1),C'?'
- BNE SET10
- SPRINT ' Set parameters are:'
- SPRINT ' filetype set to text for normal, readable files,+
- '
- SPRINT ' or saved for unformatted byte streams'
- SPRINT ' that have originated on another system'
- SPRINT ' and contain embedded formatting data;'
- SPRINT ' default is text'
- SPRINT ' endofline set to decimal value of a control'
- SPRINT ' character to be used as end of line'
- SPRINT ' (packet) terminator in send operations;+
- '
- SPRINT ' default is 13 (CR), some systems want'
- SPRINT ' 10 (LF); must be 0-31'
- SPRINT ' debug on or off; puts all packets in -debug'
- B MAINLOOP
- SET10 LR R3,R1
- BAL R9,BRKEQ
- LR R4,R1 Length of parameter
- SR R4,R3
- S R4,=F'1' (-1 for ex)
- BL SETERR No operand
- CLI 0(R1),C'=' Must be an =
- BNE SETERR
- LA R1,1(,R1)
- S R2,=F'1'
- LA R5,SETTAB Point at parameter table
- SET20 C R4,4(,R5) Meet minimum length requirement?
- BL SET30 No
- EX R4,SETCLC Match prefix of parameter?
- BNE SET30 No
- L R3,0(,R5) Yes -- branch to handler
- BR R3
- SET30 LA R5,SETELEN(,R5) Next parameter table entry
- CLC 0(4,R5),=F'0' Error if end of table
- BNE SET20
- SETERR SPRINT ' Invalid set parameter. Valid parameters are:'
- SPRINT ' filetype=text, filetype=saved'
- SPRINT ' endofline=dd (dd=0-31)'
- SPRINT ' debug=on, debug=off'
- B MAINLOOP
- SETCLC CLC 0(*-*,R3),8(R5)
- SPACE 1
- * Parameter table. Same format as command table.
- SETTAB DC A(SETFT),F'0',CL16'FILETYPE'
- DC A(SETEOL),F'0',CL16'ENDOFLINE'
- DC A(SETDEB),F'0',CL16'DEBUG'
- DC A(0)
- SETELEN EQU 24
- SPACE 1
- SETFT LTR R2,R2 Must be something there
- BNH SETERR
- CLI 0(R1),C'T' Accept anything that starts with
- BE SETFTOK t or s
- CLI 0(R1),C'S'
- BNE SETERR
- SETFTOK MVC FILETYPE(1),0(R1)
- BAL R9,BRKBL Might be more parameters to set
- BAL R9,SPNBL
- LTR R2,R2
- BNH MAINLOOP
- B SET10
- SPACE 1
- SETEOL LTR R2,R2 Must be something there
- BNH SETERR
- SR R3,R3 Convert from decimal to binary
- SETEOL10 CLI 0(R1),C'0' the hard way
- BL SETERR
- CLI 0(R1),C'9'
- BH SETERR
- MH R3,=H'10'
- SR R4,R4
- IC R4,0(R1)
- S R4,=A(C'0')
- AR R3,R4
- C R3,=F'31' Maximum allowed is 31
- BH SETERR
- LA R1,1(,R1)
- S R2,=F'1'
- BNH SETEOL20
- CLI 0(R1),C' '
- BNE SETEOL10
- SETEOL20 STC R3,EOLCHAR
- BAL R9,BRKBL Might be more parameters to set
- BAL R9,SPNBL
- LTR R2,R2
- BNH MAINLOOP
- B SET10
- SPACE 1
- SETDEB LTR R2,R2 Must be something there
- BNH SETERR
- CLC 0(2,R1),=C'ON' Accept anything that starts with
- BE SETDEB10 on or of
- CLC 0(2,R1),=C'OF'
- BNE SETERR
- MVI DEBUG,0
- B SETDEB20
- SETDEB10 MVI DEBUG,1
- SETDEB20 BAL R9,BRKBL Might be more parameters to set
- BAL R9,SPNBL
- LTR R2,R2
- BNH MAINLOOP
- B SET10
- TITLE 'Commands -- send'
- SEND BAL R9,SPNBL
- SENDSRV LR R3,R1 Extract filespec
- BAL R9,BRKBL
- LR R4,R1
- BAL R9,SPNBL
- LTR R2,R2
- BNH SEND20
- CLI SERVER,1
- BE SEND10
- SPRINT ' Send takes a single file spec argument'
- B MAINLOOP
- SEND10 MVC PACKET(37),=C'EExtra junk at end of rcv-init packet'
- MVI WPCKTNUM,0
- LA R1,37
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SEND20 LR R1,R3 Point at filespec
- LR R2,R4
- SR R2,R1
- BAL R9,EXPFSPC Expand filespec
- CLC NFILES(4),=F'0'
- BH SEND40
- CLI SERVER,1
- BE SEND30
- SPRINT ' File not found'
- B MAINLOOP
- SEND30 MVC PACKET(15),=C'EFile not found'
- MVI WPCKTNUM,0
- LA R1,15
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SEND40 MVI WPCKTNUM,0 Reset output packet number
- XC RETRYCNT,RETRYCNT and retry counter
- SEND50 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCS Send-init packet
- MVI PACKET+1,94+32 My max packet length
- MVI PACKET+2,5+32 Time out in 5 seconds
- MVI PACKET+3,4+32 4 turnaround pad characters needed
- MVI PACKET+4,0+64 Use null for pad character
- MVI PACKET+5,13+32 End of line character (CR)
- MVI PACKET+6,35 Control character quote (#)
- MVI PACKET+7,ASCY I can do 8-bit quoting
- MVI PACKET+8,49 1-character checksum (1)
- MVI PACKET+9,126 Repeat prefix character (tilde)
- LA R1,10
- BAL R9,WRPACKET
- BAL R9,RDPACKET
- BNZ SEND50
- CLI PACKET,ASCN
- BE SEND50
- CLI PACKET,ASCY
- BNE ABORT
- CLC RPCKTNUM(1),WPCKTNUM
- BNE SEND50
- MVC MPLEN(4),=F'94' Set defaults
- MVC NPAD(4),=F'0'
- MVI PADCHAR,0
- MVC EOLCHAR2(1),EOLCHAR
- MVI CTLQT,35
- MVI BINQT,ASCN
- MVI RPTCHAR,32
- LR R2,R1
- S R2,=F'1'
- BNH SENDNXTF
- SR R1,R1 Copy his parameters
- IC R1,PACKET+1
- S R1,=F'32'
- ST R1,MPLEN Maximum packet length
- S R2,=F'2'
- BNH SENDNXTF
- IC R1,PACKET+3
- S R1,=F'32'
- ST R1,NPAD Number of pad characters
- S R2,=F'1'
- BNH SENDNXTF
- IC R1,PACKET+4
- X R1,=F'64'
- STC R1,PADCHAR Pad character
- S R2,=F'1'
- BNH SENDNXTF
- IC R1,PACKET+5
- S R1,=F'32'
- STC R1,EOLCHAR2 End of line character
- S R2,=F'1'
- BNH SENDNXTF
- MVC CTLQT(1),PACKET+6 Control character quote
- S R2,=F'1'
- BNH SENDNXTF
- MVC BINQT(1),PACKET+7 Binary (8-bit) quote character
- S R2,=F'2'
- BNH SENDNXTF
- MVC RPTCHAR(1),PACKET+9 Compression prefix character
- SENDNXTF L R1,NFILES Open next file
- S R1,=F'1'
- ST R1,NFILES
- BL SBREAK Sent all of them
- SLL R1,6 Point at FDname (64 characters)
- A R1,=A(FILES)
- MVC FILENAME(64),0(R1) Copy name for file header
- LA R1,FILENAME
- CALL GETFD
- LTR R15,R15
- BZ SEND80
- SEND60 CLI NETDEV,X'FF'
- BE SEND70
- SPRINT ' Unable to open file'
- B SBREAK
- SEND70 MVC PACKET(20),=C'EUnable to open file'
- MVI WPCKTNUM,0
- LA R1,20
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- SEND80 ST R0,FDUB
- CALL GDINFO Open the file
- LTR R15,R15
- BNZ SEND60
- MVC WORK(1),13(R1)
- SR R0,R0 Free gdinfo block
- CALL FREESPAC
- CLI WORK,X'FF' Check for type=none
- BE SEND60
- XC BUFFCNT,BUFFCNT File buffer is empty
- MVI EOFFLAG,0 Not at end of file
- XC RETRYCNT,RETRYCNT
- IC R1,WPCKTNUM
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- CLI NETDEV,X'FF'
- BE SENDFHDR
- MVC SCBUF(9),=C' Sending '
- MVC SCBUF+9(64),FILENAME
- LA R2,73
- SPRINT SCBUF,(R2)
- SENDFHDR L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,C'F' Send file header packet
- MVC PACKET+1(64),FILENAME
- LA R1,PACKET+64 Trim trailing blanks off name
- SEND90 CLI 0(R1),C' '
- BNE SEND100
- S R1,=F'1'
- B SEND90
- SEND100 S R1,=A(PACKET)
- LA R1,1(,R1)
- BAL R9,TRETOA
- BAL R9,WRPACKET
- BAL R9,RDPACKET
- BNZ SENDFHDR
- CLI PACKET,ASCN
- BNE SEND110
- IC R2,RPCKTNUM Nak for next packet is same as
- A R2,=F'63' ack for this packet
- STC R2,WORK
- NI WORK,63
- CLC WORK(1),WPCKTNUM
- BNE SENDFHDR
- B SEND120
- SEND110 CLI PACKET,ASCY
- BNE ABORT
- CLC WPCKTNUM(1),RPCKTNUM
- BNE SENDFHDR
- SEND120 XC RETRYCNT,RETRYCNT
- IC R1,WPCKTNUM
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- XC PCKTLEN,PCKTLEN
- SEND130 L R1,BUFFCNT Get next character from file
- LTR R1,R1
- BNZ SEND160
- CLI EOFFLAG,0 End of line; also end of file?
- BE SEND140
- CLC PCKTLEN(4),=F'0' End of file; anything in packet?
- BE SENDEOF
- B SENDDATA
- SEND140 CALL READ,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
- LTR R15,R15
- BZ SEND150
- MVI EOFFLAG,1
- B SEND130
- SEND150 LH R1,BUFLEN
- ST R1,BUFFCNT
- SEND160 LH R0,BUFLEN Point at next char in buffer
- SR R0,R1
- A R0,=A(BUFFER)
- LR R4,R0
- CLI RPTCHAR,32 Is compression allowed?
- BE SEND180 No
- IC R3,0(,R4) Tricky clcl to see how many of
- SLL R3,24 this character there are
- CLCL R0,R2
- SR R0,R4 There are this many
- C R0,=F'4'
- BL SEND180 Not worth the bother
- C R0,=F'94' Can't have too many either
- BNH SEND170
- LA R0,94
- SEND170 L R1,BUFFCNT Consume this many characters
- SR R1,R0
- ST R1,BUFFCNT
- L R1,PCKTLEN Put out prefix and count
- LA R2,PACKET+1(R1)
- MVC 0(1,R2),RPTCHAR
- A R0,=F'32'
- STC R0,1(,R2)
- LA R1,2(,R1)
- ST R1,PCKTLEN
- B SEND190
- SEND180 L R1,BUFFCNT Consume one character
- S R1,=F'1'
- ST R1,BUFFCNT
- SEND190 MVC WORK(1),0(R4) Translate char if filetype=text
- CLI FILETYPE,C'T'
- BNE SEND200
- TR WORK(1),ETOA
- B SEND210 No parity quoting needed
- SEND200 TM WORK,X'80'
- BZ SEND210
- CLI BINQT,ASCN Is binary quoting allowed?
- BE SEND210 No -- send it the way it is
- L R1,PCKTLEN Put out 8-bit prefix
- LA R2,PACKET+1(R1)
- MVC 0(1,R2),BINQT
- LA R1,1(,R1)
- ST R1,PCKTLEN
- NI WORK,X'7F'
- SEND210 CLI WORK,127 See if control quoting needed
- BE SEND220
- CLI WORK,31
- BNH SEND220
- CLC WORK(1),CTLQT
- BE SEND230
- CLI BINQT,ASCN
- BE SEND215
- CLC WORK(1),BINQT
- BE SEND230
- SEND215 CLI RPTCHAR,32
- BE SEND240
- CLC WORK(1),RPTCHAR
- BNE SEND240
- B SEND230
- SEND220 XI WORK,64 Not a control char anymore
- SEND230 L R1,PCKTLEN Put out control prefix
- LA R2,PACKET+1(R1)
- MVC 0(1,R2),CTLQT
- LA R1,1(,R1)
- ST R1,PCKTLEN
- SEND240 L R1,PCKTLEN Finally, put in the character
- LA R2,PACKET+1(R1)
- MVC 0(1,R2),WORK
- LA R1,1(,R1)
- ST R1,PCKTLEN
- CLC BUFFCNT(4),=F'0' One last thing -- put crlf at eol
- BNE SEND250
- CLI FILETYPE,C'T' if filetype=text
- BNE SEND250
- L R1,PCKTLEN
- LA R2,PACKET+1(R1)
- MVC 0(1,R2),CTLQT
- MVI 1(R2),77
- MVC 2(1,R2),CTLQT
- MVI 3(R2),74
- LA R1,4(,R1)
- ST R1,PCKTLEN
- SEND250 L R1,PCKTLEN Have we about filled a packet?
- A R1,=F'10'
- C R1,MPLEN
- BL SEND130 No, loop
- SENDDATA L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCD Send data packet
- L R1,PCKTLEN
- A R1,=F'1'
- BAL R9,WRPACKET
- BAL R9,RDPACKET
- BNZ SENDDATA
- CLI PACKET,ASCN
- BNE SEND260
- IC R2,RPCKTNUM Nak for next packet is same as
- A R2,=F'63' ack for this packet
- STC R2,WORK
- NI WORK,63
- CLC WORK(1),WPCKTNUM
- BNE SENDDATA
- B SEND120
- SEND260 CLI PACKET,ASCY
- BNE ABORT
- CLC WPCKTNUM(1),RPCKTNUM
- BNE SENDDATA
- XC PCKTLEN,PCKTLEN Packet now empty
- B SEND120 Loop through whole file
- SENDEOF XC RETRYCNT,RETRYCNT
- SENDEOFL L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCZ Send end of file packet
- LA R1,1
- BAL R9,WRPACKET
- BAL R9,RDPACKET
- BNZ SENDEOFL
- CLI PACKET,ASCN
- BNE SEND270
- IC R2,RPCKTNUM Nak for next packet is same as
- A R2,=F'63' ack for this packet
- STC R2,WORK
- NI WORK,63
- CLC WORK(1),WPCKTNUM
- BNE SENDEOFL
- B SEND280
- SEND270 CLI PACKET,ASCY
- BNE ABORT
- CLC WPCKTNUM(1),RPCKTNUM
- BNE SENDEOFL
- SEND280 L R0,FDUB Close the file
- CALL FREEFD
- B SENDNXTF Send next file, if any
- SBREAK XC RETRYCNT,RETRYCNT
- IC R1,WPCKTNUM
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- SBREAKL L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCB Send break (EOT) packet
- LA R1,1
- BAL R9,WRPACKET
- BAL R9,RDPACKET
- BNZ SBREAKL
- CLI PACKET,ASCN
- BNE SEND290
- IC R2,RPCKTNUM Nak for next packet is same as
- A R2,=F'63' ack for this packet
- STC R2,WORK
- NI WORK,63
- CLC WORK(1),WPCKTNUM
- BNE SBREAKL
- B MAINLOOP
- SEND290 CLI PACKET,ASCY
- BNE ABORT
- CLC WPCKTNUM(1),RPCKTNUM
- BNE SBREAKL
- B MAINLOOP
- TITLE 'Commands -- receive'
- RECEIVE BAL R9,SPNBL Extract file spec, if any
- LR R3,R1
- BAL R9,BRKBL
- CR R1,R3
- BE REC10 No file spec
- LR R4,R1
- SR R4,R3
- S R4,=F'1' Copy file spec into packet
- EX R4,RECFSMVC
- MVI PACKET,C'R'
- MVI WPCKTNUM,0
- LA R1,2(,R4)
- BAL R9,TRETOA
- BAL R9,WRPACKET Send rcv-init packet
- REC10 XC RETRYCNT,RETRYCNT
- REC20 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- BAL R9,RDPACKET Wait for send-init packet
- BNE REC20
- CLI PACKET,ASCN
- BE REC20
- CLI PACKET,ASCS
- BNE ABORT
- XC RETRYCNT,RETRYCNT
- B REC30
- RECFSMVC MVC PACKET+1(*-*),0(R3)
- GOTS BAL R9,TRETOA
- XC RETRYCNT,RETRYCNT
- REC30 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVC MPLEN(4),=F'94' Set defaults
- MVC NPAD(4),=F'0'
- MVI PADCHAR,0
- MVC EOLCHAR2(1),EOLCHAR
- MVI CTLQT,35
- MVI BINQT,ASCN
- MVI RPTCHAR,32
- LR R2,R1
- S R2,=F'1'
- BNH REC50
- SR R1,R1 Copy his parameters
- IC R1,PACKET+1
- S R1,=F'32'
- ST R1,MPLEN Maximum packet length
- S R2,=F'2'
- BNH REC50
- IC R1,PACKET+3
- S R1,=F'32'
- ST R1,NPAD Number of pad characters
- S R2,=F'1'
- BNH REC50
- IC R1,PACKET+4
- X R1,=F'64'
- STC R1,PADCHAR Pad character
- S R2,=F'1'
- BNH REC50
- IC R1,PACKET+5
- S R1,=F'32'
- STC R1,EOLCHAR2 End of line character
- S R2,=F'1'
- BNH REC50
- MVC CTLQT(1),PACKET+6 Control character quote
- S R2,=F'1'
- BNH REC50
- MVC BINQT(1),PACKET+7 Binary (8-bit) quote character
- CLI BINQT,ASCY
- BNE REC40
- MVI BINQT,38 Use & if he said Y
- REC40 S R2,=F'2'
- BNH REC50
- MVC RPTCHAR(1),PACKET+9 Compression prefix character
- REC50 MVI PACKET,ASCY Send back ack with parameters
- L R1,MPLEN
- A R1,=F'32'
- STC R1,PACKET+1 Use his max packet length
- MVI PACKET+2,5+32 Time out in 5 seconds
- MVI PACKET+3,4+32 4 turnaround pad characters needed
- MVI PACKET+4,0+64 Use null for pad character
- MVI PACKET+5,13+32 End of line character I want (CR)
- MVC PACKET+6(1),CTLQT Control character quote
- MVC PACKET+7(1),BINQT 8-bit quote
- MVI PACKET+8,49 1-character checksum (1)
- MVC PACKET+9(1),RPTCHAR Repeat prefix character
- MVI WPCKTNUM,0
- LA R1,10
- BAL R9,WRPACKET
- BAL R9,RDPACKET Read for first F packet
- BNZ REC30
- CLI PACKET,ASCN
- BE REC30
- CLI PACKET,ASCS
- BE REC30
- CLI PACKET,ASCF
- BNE ABORT
- REC60 MVC FILENAME(64),=CL64' ' Extract file name from packet
- BAL R9,TRATOE
- S R1,=F'2'
- BH REC70
- MVC PACKET(18),=C'EMissing file name'
- MVI WPCKTNUM,0
- LA R1,18
- BAL R9,WRPACKET
- B ABORT
- RECFMVC MVC FILENAME(*-*),PACKET+1
- REC70 EX R1,RECFMVC
- REC80 LA R1,FILENAME
- CALL GETFD Attempt to open the file
- LTR R15,R15
- BZ REC110
- REC90 CLI NETDEV,X'FF'
- BE REC100
- SPRINT ' Unable to open file'
- B ABORT
- REC100 MVC PACKET(20),=C'EUnable to open file'
- MVI WPCKTNUM,0
- LA R1,20
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- REC110 ST R0,FDUB
- CALL GDINFO Open the file
- LTR R15,R15
- BNZ REC90
- MVC WORK(1),13(R1)
- SR R0,R0 Free gdinfo block
- CALL FREESPAC
- CLI WORK,X'FF' Check for type=none
- BNE REC120
- CALL CREATE,(FILENAME,CRESIZE,CREVOL,CRETYPE) Try to create
- LTR R15,R15 the file
- BNZ REC90 Too bad
- B REC80 Try the open again
- REC120 L R0,FDUB Empty the file
- CALL EMPTY
- XC BUFLEN,BUFLEN
- MVI CRFLAG,0
- IC R1,WPCKTNUM
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- XC RETRYCNT,RETRYCNT
- CLI NETDEV,X'FF'
- BE REC130
- MVC SCBUF(11),=C' Receiving '
- MVC SCBUF+11(64),FILENAME
- LA R2,75
- SPRINT SCBUF,(R2)
- REC130 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCY
- LA R1,1
- BAL R9,WRPACKET Ack the F packet
- BAL R9,RDPACKET
- BNZ REC130
- CLI PACKET,ASCN
- BE REC130
- CLC WPCKTNUM(1),RPCKTNUM Ack again if F again
- BE REC130
- RECDATA CLI PACKET,ASCD Expecting D or Z packet
- BE REC140
- CLI PACKET,ASCZ
- BE RECEOF
- B ABORT Sequence error
- REC140 LR R2,R1 Length of packet
- S R2,=F'1' Account for D at front
- LA R3,PACKET+1
- REC150 LTR R2,R2 Anything left in packet?
- BNH REC290 No
- MVC WORK(1),0(R3) Copy char with/out parity
- MVC WORK+1(1),0(R3)
- NI WORK+1,X'7F'
- LA R4,1 Default repeat count
- CLI RPTCHAR,32 Compression allowed?
- BE REC160 No
- CLC WORK+1(1),RPTCHAR Repetition prefix?
- BNE REC160 No
- IC R4,1(,R3) Get repeat count
- N R4,=F'127'
- S R4,=F'32'
- S R2,=F'2'
- BNH ABORT
- LA R3,2(,R3)
- MVC WORK(1),0(R3)
- MVC WORK+1(1),0(R3)
- NI WORK+1,X'7F'
- REC160 SR R5,R5 Default high-order bit value
- CLI BINQT,ASCN 8-bit quoting enabled?
- BE REC170 No
- CLC WORK+1(1),BINQT
- BNE REC170
- LA R5,128 Turn on high bit later
- S R2,=F'1'
- BNH ABORT
- LA R3,1(,R3)
- MVC WORK(1),0(R3)
- MVC WORK+1(1),0(R3)
- NI WORK+1,X'7F'
- REC170 CLC WORK+1(1),CTLQT Is it a control quote?
- BNE REC210 No
- MVC WORK(1),1(R3)
- MVC WORK+1(1),1(R3)
- NI WORK+1,X'7F'
- CLC WORK+1(1),CTLQT May be quoting a literal
- BE REC200
- CLI RPTCHAR,32
- BE REC180
- CLC WORK+1(1),RPTCHAR
- BE REC200
- REC180 CLI BINQT,ASCN
- BE REC190
- CLC WORK+1(1),BINQT
- BE REC200
- * Will not get here if control quote is followed by
- * quote with high order bit on (eg X'23A3').
- REC190 XI WORK,64 Make it into a control char
- REC200 S R2,=F'1'
- BNH ABORT
- LA R3,1(,R3)
- REC210 SR R6,R6
- IC R6,WORK Diddle with high bit
- CLI BINQT,ASCN Straight through if no bin quote
- BE REC215
- N R6,=F'127' Otherwise 0 if no quote seen
- OR R6,R5 or 1 if quote seen
- REC215 CLI FILETYPE,C'T' Translate to ebcdic if filetype=text
- BNE REC220
- IC R6,ATOE(R6)
- REC220 STC R6,WORK WORK has char, R4 has count
- LA R3,1(,R3) Account for the character
- S R2,=F'1'
- BL ABORT
- CLI FILETYPE,C'T' Look for CRLF in text files
- BNE REC260
- CLI WORK,13 Is this a CR?
- BNE REC230 No
- C R4,=F'1' Better not be repeated
- BNE ABORT
- MVI CRFLAG,1 Set flag to say we've seen CR
- B REC150
- REC230 CLI WORK,X'25' Is this a LF?
- BNE REC250
- C R4,=F'1' Better not be repeated
- BNE ABORT
- CLI CRFLAG,1 Was last char a CR?
- BNE ABORT Don't like LF's without CR's
- LH R1,BUFLEN
- LTR R1,R1 Replace zero-length lines with blank
- BH REC240
- LA R1,1
- STH R1,BUFLEN
- L R1,=A(BUFFER)
- MVI 0(R1),C' '
- REC240 CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
- LTR R15,R15
- BNE WRTFERR Error writing to file
- XC BUFLEN,BUFLEN
- MVI CRFLAG,0
- B REC150
- REC250 CLI CRFLAG,0 Don't like CR's without LF's
- BNE ABORT
- REC260 LH R5,BUFLEN Point into buffer
- LR R6,R5
- A R6,=A(BUFFER)
- REC270 MVC 0(1,R6),WORK Copy character to buffer
- LA R6,1(,R6)
- LA R5,1(,R5)
- C R5,=F'32767' Don't overflow buffer
- BL REC280
- STH R5,BUFLEN
- CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
- LTR R15,R15
- BNE WRTFERR Error writing to file
- SR R5,R5
- L R6,=A(BUFFER)
- REC280 BCT R4,REC270 Repeat as necessary
- STH R5,BUFLEN New buffer length
- B REC150 Next character from packet
- REC290 IC R1,WPCKTNUM Bump write packet number
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- XC RETRYCNT,RETRYCNT
- REC300 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCY
- LA R1,1
- BAL R9,WRPACKET Ack the D packet
- BAL R9,RDPACKET
- BNZ REC300
- CLI PACKET,ASCN
- BE REC300
- CLC WPCKTNUM(1),RPCKTNUM Ack again if last packet again
- BE REC300
- B RECDATA Loop until Z packet
- RECEOF CLC BUFLEN(2),=H'0' Write out contents of buffer, if any
- BE REC310
- CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
- LTR R15,R15
- BNZ WRTFERR
- REC310 L R0,FDUB Close the file
- CALL FREEFD
- IC R1,WPCKTNUM Bump write packet number
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- XC RETRYCNT,RETRYCNT
- REC320 L R1,RETRYCNT
- LA R1,1(,R1)
- ST R1,RETRYCNT
- C R1,MAXRETRY
- BH ABORT
- MVI PACKET,ASCY
- LA R1,1
- BAL R9,WRPACKET Ack the Z packet
- BAL R9,RDPACKET
- BNZ REC320
- CLI PACKET,ASCN
- BE REC320
- CLC WPCKTNUM(1),RPCKTNUM Ack again if last packete again
- BE REC320
- CLI PACKET,ASCF Expecting F or B packet
- BE REC60 Process next file
- CLI PACKET,ASCB
- BNE ABORT
- IC R1,WPCKTNUM Bump write packet number
- LA R1,1(,R1)
- STC R1,WPCKTNUM
- NI WPCKTNUM,63
- MVI PACKET,ASCY
- LA R1,1
- BAL R9,WRPACKET Ack the B packet
- B MAINLOOP All done the receive
- TITLE 'WRPACKET -- write out a packet'
- WRPACKET LA R2,PACKET2 Build output packet here
- L R3,NPAD Put pads in first
- LTR R3,R3
- BZ WRP20
- WRP10 MVC 0(1,R2),PADCHAR
- LA R2,1(,R2)
- BCT R3,WRP10
- WRP20 MVI 0(R2),1 SOH character
- SR R4,R4 Checksum
- LA R3,34(,R1) Length byte (R1+2+32)
- STC R3,1(,R2)
- AR R4,R3
- IC R3,WPCKTNUM Sequence id
- LA R3,32(,R3)
- STC R3,2(,R2)
- AR R4,R3
- LA R2,3(,R2)
- LA R5,PACKET Copy the packet proper
- WRP30 MVC 0(1,R2),0(R5)
- IC R3,0(,R5)
- AR R4,R3
- LA R2,1(,R2)
- LA R5,1(,R5)
- BCT R1,WRP30
- N R4,=F'255' Crunch checksum to 6 bits
- LR R3,R4
- SRL R3,6
- AR R4,R3
- N R4,=F'63'
- A R4,=F'32'
- STC R4,0(,R2)
- MVC 1(1,R2),EOLCHAR2 Line terminator
- LA R2,2(,R2)
- LA R1,PACKET2 Length of finished packet
- SR R2,R1
- CLI SERVER,1 Select unit based on server flag
- BE WRP40 Server always uses sprint,
- CLI NETDEV,X'FF' non-server uses 0 if assigned,
- BE WRP40 and sprint otherwise
- MVC RWPKUNIT(4),=F'0'
- B WRP50
- WRP40 MVC RWPKUNIT(8),=C'SPRINT '
- WRP50 STH R2,RWPKLEN
- CALL WRITE,(PACKET2,RWPKLEN,RWPKMOD,RWPKLNUM,RWPKUNIT)
- CLI DEBUG,0
- BER R9
- LA R2,1(,R2)
- STH R2,DEBLEN
- CALL WRITE,(DEBPK2,DEBLEN,DEBMOD,DEBLNUM,DEBUNIT)
- BR R9
- TITLE 'RDPACKET -- read a packet'
- RDPACKET CLI SERVER,1 Select unit based on server flag
- BE RDP10 Server always uses scards,
- CLI NETDEV,X'FF' non-server uses 0 if assigned,
- BE RDP10 and scards otherwise
- MVC RWPKUNIT(4),=F'0'
- B RDP20
- RDP10 MVC RWPKUNIT(8),=C'SCARDS '
- RDP20 CALL READ,(PACKET3,RWPKLEN,RWPKMOD,RWPKLNUM,RWPKUNIT)
- LH R1,RWPKLEN
- *
- *#### Merit READ@BIN returns data in EBCDIC so restore to ASCII
- *
- L R4,=V(EBCMASC)
- STEP#1 EX R1,TREBMASC
- *
- CLI DEBUG,0
- BE RDP30
- LA R2,1(,R1)
- STH R2,DEBLEN
- CALL WRITE,(DEBPK3,DEBLEN,DEBMOD,DEBLNUM,DEBUNIT)
- LH R1,RWPKLEN
- RDP30 LTR R1,R1
- BNH RDPFAIL
- C R1,=F'120' Generous overlength check
- BH PTOOLONG
- MVI WORK+1,X'7F' Mask to turn off parity, as nec
- CLI FILETYPE,C'T'
- BE RDP40
- CLI BINQT,ASCN
- BNE RDP40
- MVI WORK+1,X'FF'
- RDP40 LA R2,PACKET3
- RDP50 MVC WORK(1),0(R2)
- NC WORK(1),WORK+1
- CLI WORK,1 Look for soh
- BE RDP60
- LA R2,1(,R2)
- BCT R1,RDP50
- B RDPFAIL
- RDP60 LA R2,1(,R2)
- S R1,=F'1'
- BNH RDPFAIL
- MVC WORK(1),0(R2)
- NC WORK(1),WORK+1
- SR R3,R3 Length byte
- IC R3,WORK
- LR R4,R3 This will be checksum
- S R3,=F'34'
- BNH RDPFAIL
- ST R3,PCKTLEN Save packet length
- LA R2,1(,R2)
- S R1,=F'1'
- BNH RDPFAIL
- MVC WORK(1),0(R2)
- NC WORK(1),WORK+1
- SR R5,R5 Packet sequence number
- IC R5,WORK
- AR R4,R5
- S R5,=F'32'
- STC R5,RPCKTNUM
- LA R2,1(,R2)
- S R1,=F'1'
- BNH RDPFAIL
- LA R6,PACKET
- RDP70 MVC WORK(1),0(R2) Copy the packet proper
- NC WORK(1),WORK+1
- IC R5,WORK
- AR R4,R5
- STC R5,0(,R6)
- LA R6,1(,R6)
- LA R2,1(,R2)
- S R1,=F'1'
- BNH RDPFAIL
- BCT R3,RDP70
- MVC WORK(1),0(R2) Check the checksum
- NC WORK(1),WORK+1
- IC R5,WORK
- S R5,=F'32'
- N R4,=F'255'
- LR R6,R4
- SRL R6,6
- AR R4,R6
- N R4,=F'63'
- CR R4,R5
- BNE RDPFAIL
- L R1,PCKTLEN Return with CC Z and len in R1
- CLI PACKET,ASCE Is it an error packet?
- BE ERRPCKT Boom
- SR R0,R0
- BR R9
- RDPFAIL SR R1,R1 Return with CC NZ
- LTR R11,R11
- BR R9
- TITLE 'Translation from/to ascii/ebcdic'
- TRETOA S R1,=F'1'
- BL TRETOA10
- EX R1,TRETOATR
- TRETOA10 A R1,=F'1'
- BR R9
- TRETOATR TR PACKET(*-*),ETOA
- SPACE 1
- TRATOE S R1,=F'1'
- BL TRATOE10
- EX R1,TRATOETR
- TRATOE10 A R1,=F'1'
- BR R9
- TRATOETR TR PACKET(*-*),ATOE
- SPACE 1
- TREBMASC TR PACKET3(*-*),0(R4)
- TITLE 'Routine to expand a file spec'
- EXPFSPC XC NFILES,NFILES Init number of files found
- MVC FILESPEC(64),=CL64' ' Copy the file spec
- S R2,=F'1'
- BLR R9
- C R2,=F'59'
- BH EXPFERR
- EX R2,EXPFMVC
- A R2,=F'1'
- TR FILESPEC(64),LCUC
- CALL GUINFO,(TWO,MYUID) Determine current signon userid
- CLI FILESPEC,C'*'
- BNE EXPF10
- MVC USERID(4),=C'*SYS'
- B EXPF60
- EXPFMVC MVC FILESPEC(*-*),0(R1)
- EXPF10 CLI FILESPEC,C'-'
- BNE EXPF20
- MVC USERID(4),=C'*TMP'
- B EXPF60
- EXPF20 LA R1,FILESPEC Copy userid if any
- LA R2,4
- MVC USERID(4),=C'$.$.' Userid pad characters
- EXPF30 CLI 0(R1),C':'
- BE EXPF40
- MVC 0(1,R3),0(R1)
- LA R1,1(,R1)
- LA R3,1(,R3)
- BCT R2,EXPF30
- CLI 0(R1),C':' If no colon here, no userid given
- BNE EXPF50
- EXPF40 MVC FILESPEC(60),1(R1) Crunch out userid
- B EXPF60
- EXPF50 MVC USERID(4),MYUID Default is current signonid
- EXPF60 XC GFINFR(24),GFINFR
- EXPF70 CALL GFINFO,(USERID,GFINFR,THREE,GFINFZ,GFINFZ,GFINFZ),VL
- LTR R15,R15
- BNZR R9 No more files
- MVC FILENAME(64),=CL64' '
- CLC USERID(4),MYUID Gfinfo includes userid only if it's
- BE EXPF80 not for this task (sweet, eh)
- CLC USERID(4),=C'*SYS'
- BE EXPF80
- CLC USERID(4),=C'*TMP'
- BE EXPF80
- MVC FILENAME(4),GFINFR
- MVI FILENAME+4,C':'
- MVC FILENAME+5(16),GFINFR+4
- LA R1,FILENAME+5
- B EXPF90
- EXPF80 MVC FILENAME(20),GFINFR
- LA R1,FILENAME
- * Allow single ? in file spec -- matches any substring
- EXPF90 LA R2,FILESPEC
- SR R3,R3 No ? yet
- SR R4,R4
- EXPF100 CLI 0(R1),C' ' End of filename?
- BNE EXPF110 No
- CLI 0(R2),C' ' End of file spec?
- BNE EXPF70 No -- doesn't match
- L R1,NFILES Found a matching file name
- LR R2,R1
- SLL R2,6
- A R2,=A(FILES)
- MVC 0(64,R2),FILENAME
- LA R1,1(,R1)
- C R1,=F'64' Check for too many
- BH EXPFERR
- ST R1,NFILES
- B EXPF70 Look for more
- EXPF110 CLC 0(1,R1),0(R2) Characters match?
- BNE EXPF120 No
- LA R1,1(,R1) Yes -- move along
- LA R2,1(,R2)
- B EXPF100 Loop
- EXPF120 CLI 0(R2),C'?' ? in file spec?
- BNE EXPF130
- LTR R3,R3 Seen one before?
- BNZ EXPFERR Yes -- error
- LA R2,1(,R2) Point past ?
- LR R3,R2 and save this address
- LA R4,1(,R1) This is where to continue after fail
- B EXPF100 Continue matching
- EXPF130 LTR R3,R3 Mismatch -- have we seen a ?
- BZ EXPF70 No -- names can't match
- LR R2,R3 Lengthen string matched by ?
- LR R1,R4
- LA R4,1(,R1)
- B EXPF100 and try again
- SPACE 1
- EXPFERR CLI NETDEV,X'FF'
- BE EXPF140
- SPRINT ' Error expanding file spec'
- MVI PACKET,ASCB Send break packet
- MVI WPCKTNUM,0
- LA R1,1
- BAL R9,WRPACKET
- B MAINLOOP
- EXPF140 MVC PACKET(26),=C'EError expanding file spec'
- MVI WPCKTNUM,0
- LA R1,26
- BAL R9,TRETOA
- BAL R9,WRPACKET
- B MAINLOOP
- TITLE 'Constants and variable storage'
- SAVEAREA DS 18F
- TWO DC F'2'
- THREE DC F'3'
- PFXPAR DC A(PFXITEM,PFXDATA)
- PFXITEM DC CL8'PFXSTR '
- PFXDATA DC F'19',F'11',CL11'Kermit-MTS>'
- WORK DS D
- NETCMD DC A(*+12),A(*+4),F'37',C'$NET '
- NETDEV DS CL32
- SERVER DS X
- FILETYPE DS X
- DEBUG DS X
- RETRYCNT DS F
- MAXRETRY DC F'10'
- CMDPTR DS A
- DC A(CMDLEN) MUST FOLLOW CMDPTR
- CMDLEN DS F
- SCBUF DS CL256
- SCLEN DC H'0',H'255',H'0'
- SCMOD DC A(X'08000000') Maxlen
- SCLNUM DS F
- NFILES DS F
- FILENAME DS CL64
- FILESPEC DS CL64
- USERID DS CL4
- MYUID DS CL4
- DS 0F
- CRESIZE DC H'0',H'1'
- CREVOL DC XL6'00'
- CRETYPE DC F'256'
- RPCKTNUM DS X
- WPCKTNUM DS X
- PCKTLEN DS F
- PACKET DS CL150
- DEBPK2 DC X'E2' MUST PRECEED PACKET2
- PACKET2 DS CL150
- DEBPK3 DC X'D9' MUST PRECEED PACKET3
- PACKET3 DS CL150
- RWPKLEN DC H'0',H'150',H'0'
- RWPKMOD DC A(X'08000008') Maxlen, binary
- RWPKLNUM DS F
- RWPKUNIT DS CL8
- DEBLEN DS H
- DEBMOD DC F'0'
- DEBLNUM DC F'0'
- DEBUNIT DS A
- MPLEN DS F
- NPAD DS F
- PADCHAR DS X
- EOLCHAR DS X What user wants me to send
- EOLCHAR2 DS X What other kermit wants me to send
- CTLQT DS X
- BINQT DS X
- RPTCHAR DS X
- FDUB DS A
- EOFFLAG DS X
- CRFLAG DS X
- BUFFCNT DS F
- BUFLEN DS H
- BUFMOD DC A(X'40000000')
- BUFLNUM DS F
- GFINFZ DC F'0'
- GFINFR DS 6F
- LTORG
- SPACE 1
- LCUC DC X'000102030405060708090A0B0C0D0E0F'
- DC X'101112131415161718191A1B1C1D1E1F'
- DC X'202122232425262728292A2B2C2D2E2F'
- DC X'303132333435363738393A3B3C3D3E3F'
- DC X'404142434445464748494A4B4C4D4E4F'
- DC X'505152535455565758595A5B5C5D5E5F'
- DC X'606162636465666768696A6B6C6D6E6F'
- DC X'707172737475767778797A7B7C7D7E7F'
- DC X'80C1C2C3C4C5C6C7C8C98A8B8C8D8E8F'
- DC X'90D1D2D3D4D5D6D7D8D99A9B9C9D9E9F'
- DC X'A0A1E2E3E4E5E6E7E8E9AAABACADAEAF'
- DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'
- DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'
- DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'
- DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'
- DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'
- SPACE 1
- ATOE DC X'00010203372D2E2F1605250B0C0D0E0F' Use AD/BD for sq br
- DC X'101112133C3D322618193F271C1D1E1F' Use 8B/9B for braces
- DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' Use 4F for stick
- DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' Use E0 for backslash
- DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' Use 5F for tilde
- DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD716D' Use 71 for circumflx
- DC X'79818283848586878889919293949596' Use 79 for grave
- DC X'979899A2A3A4A5A6A7A8A98B4F9B5F07' NOTE: This mapping
- DC X'00000000000000000000000000000000' is not the
- DC X'00000000000000000000000000000000' same as in the
- DC X'00000000000000000000000000000000' kermit manual.
- DC X'00000000000000000000000000000000'
- DC X'00000000000000000000000000000000'
- DC X'00000000000000000000000000000000'
- DC X'00000000000000000000000000000000'
- DC X'00000000000000000000000000000000'
- SPACE 1
- ETOA DC X'000102030009007F0000000B0C0D0E0F' Use AD/BD for sq br
- DC X'1011121300000800181900001C1D1E1F' Use 8B/9B for braces
- DC X'00000000000A171B0000000000050607' Use 4F for stick
- DC X'0000160000000004000000001415001A' Use E0 for backslash
- DC X'20000000000000000000002E3C282B7C' Use 5F for tilde
- DC X'2600000000000000000021242A293B7E' Use 71 for circumflx
- DC X'2D2F00000000000000007C2C255F3E3F' Use 79 for grave
- DC X'005E00000000000000603A2340273D22' Also use:
- DC X'00616263646566676869007B00000000' C0/D0 for braces
- DC X'006A6B6C6D6E6F707172007D00000000' A1 for tilde
- DC X'007E737475767778797A0000005B0000' NOTE: This mapping
- DC X'000000000000000000000000005D0000' is not the
- DC X'7B414243444546474849000000000000' same as in the
- DC X'7D4A4B4C4D4E4F505152000000000000' kermit manual.
- DC X'5C00535455565758595A000000000000'
- DC X'303132333435363738397C0000000000'
- SPACE 1
- FILES DS 64CL64
- BUFFER DS 32768X
- SPACE 1
- ASCB EQU 66
- ASCD EQU 68
- ASCE EQU 69
- ASCF EQU 70
- ASCN EQU 78
- ASCS EQU 83
- ASCY EQU 89
- ASCZ EQU 90
- END KERMIT
-